COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 More metering system
C00011 00003	 For the metering system
C00015 ENDMK
C⊗;
;;; More metering system
(eval-when (eval compile)
 (setq meter:refi (meter:make-name 'meter:refi)
       meter:refr (meter:make-name 'meter:refr)
       meter:array-size (meter:make-name 'meter:array-size)))

(declare 
 (*expr #.meter:refi
	#.meter:refr))

(eval-when (compile)
	   (setq old-fixsw fixsw)(fixsw ()))

(declare (special meter:sort-runtime))
(setq meter:sort-runtime ())
(declare (unspecial x y n)
	 (notype x y))

(eval-when (eval compile)
	   (cond (meter:count-only (read) 'no-runtime)))

(defun #.(meter:make-name 'meter:report) ()
       (declare (flonum total-ops total-time)
		(fixnum n i))
       (terpri)
       (princ '|Statistics|)
       (terpri)
       (princ '|= <calls> (<percentage>) [runtime (<percentage>)]|)
       (terpri)
       (let ((d-ar (get #.(meter:make-name 'meter:array-name) 'array))
	     (c-ar (get #.(meter:make-name 'meter:comment-name) 'array)))
	    (do ((i 0 (1+ i)))
		((> i #.(meter:make-name 'meter:maxf)) t)
		(terpri)(terpri)
		(princ '|Meter for: |)
		(princ (arraycall t c-ar i 0))
		(terpri)
		(let ((total-ops 0.0) 
		      (total-time 0.0)
		      (max (arraycall fixnum d-ar i)))
		     (do ((n 1 (1+ n))
			  (total (#.meter:refi
				  (* #.meter:factor i))
				 (+ total (#.meter:refi
					   (+ (* #.meter:factor i) 
					      n))))
			  (total-run (#.meter:refr
				      (* #.meter:factor i))
				     (+ total-run 
					(#.meter:refr
					 (+ (* #.meter:factor i) n)))))
			 ((> n max) (setq total-ops (float total)
					  total-time 
					  (cond ((boundp 'meter:real-runtime) 
						 (*$ 1000.0
						     (float meter:real-runtime)))
						(t (float total-run))))))
		     (do ((n 0 (1+ n)))
			 ((> n max) 
           		  (do ((n 0 (1+ n)) (stats ()))
			      ((> n max) 
			       (do ((stats 
				     (cond (meter:sort-runtime
					    (sort stats
						  #'(lambda (x y)
							    (> (cadddr (cadr x))
							       (cadddr (cadr y))))))
					   (t (sort stats
						    #'(lambda (x y)
							      (> (cadr (cadr x))
								 (cadr (cadr y)))))))
					   (cdr stats)))
				   ((null stats))
				   (let ((st (cadr (car stats))))
					(princ (car st))
					(princ '| = |)
					(princ (cadr st))
					(princ '| (|)
					(princ (caddr st))
					(princ '|%)|)
					(cond ((caar stats)
					       (princ '| |)
					       (princ '|[|)
					       (princ (cadddr st))
					       (princ '| (|)
					       (princ (cadddr (cdr st)))
					       (princ '|%)]|)))
					     (terpri)))
			       (princ '|Total = |)(princ (fix total-ops))
			       (tyo #o9)(princ '|[|) (princ (//$ total-time 1000.0))
			       (princ '|]|)
			       (terpri))
			 (let* ((index (+ (* #.meter:factor i) n))
				(x (#.meter:refi index))
				(y (#.meter:refr index)))
			      (push `(,(not (member index 
						    #.(meter:make-name
						       'meter:inc-only)))
				      (,(arraycall t c-ar i (1+ n)) 
				       ,x
				       ,(//$ 
					 (float 
					  (fix 
					   (*$ 10000.0 
					       (+$ .00005
						   (//$ (float x)
							total-ops))))) 
					 100.0)
				       ,(//$ (float y) 1000.0)
				       ,(//$ 
					 (float 
					  (fix 
					   (*$ 10000.0 
					       (+$ .00005
						   (//$ (float y)
							total-time))))) 
					 100.0))) stats)))))))))

(eval-when (eval compile)
	   (cond ((not meter:count-only) (read) 'runtime)))

(defun #.(meter:make-name 'meter:report) ()
   (declare (flonum total-ops)
	    (fixnum n i))
   (terpri)
   (princ '|Statistics|)
   (terpri)
   (princ '|= <calls> (<percentage>)|)
   (terpri)
   (let ((d-ar (get #.(meter:make-name 'meter:array-name) 'array))
	 (c-ar (get #.(meter:make-name 'meter:comment-name) 'array))
	 (cnt-ar (get #.(meter:make-name 'meter:count-array-name) 'array)))
	(do ((i 0 (1+ i)))
	    ((> i #.(meter:make-name 'meter:maxf)) t)
	    (terpri)(terpri)
	    (princ '|Meter for: |)
	    (princ (arraycall t c-ar i 0))
	    (terpri)
	    (let ((total-ops 0.0) 
		  (max (arraycall fixnum d-ar i)))
		 (do ((n 1 (1+ n))
		      (total (arraycall fixnum cnt-ar
			      (* #.meter:factor i))
			     (+ total (arraycall fixnum cnt-ar
				       (+ (* #.meter:factor i) 
					  n)))))
		     ((> n max) (setq total-ops (float total))))
		 (do ((n 0 (1+ n)) (stats ()))
		     ((> n max) 
		      (do ((stats (sort stats
					#'(lambda (x y)
						  (> (cadr x)
						     (cadr y))))
				  (cdr stats)))
			  ((null stats))
			  (princ (car (car stats)))
			  (princ '| = |)
			  (princ (cadr (car stats)))
			  (princ '| (|)
			  (princ (caddr (car stats)))
			  (princ '|%)|)(terpri))
		      (princ '|Total = |)(princ (fix total-ops))
		      (terpri))
		     (let ((x (arraycall fixnum cnt-ar
			       (+ (* #.meter:factor i) n))))
			  (push `(,(arraycall t c-ar i (1+ n)) 
				  ,x
				  ,(//$ 
				    (float 
				     (fix 
				      (*$ 10000.0 
					  (+$ .00005
					      (//$ (float x)
						   total-ops))))) 
				    100.0)) stats)))
		 ))))

(defun #.(meter:make-name 'meter:init) ()
 #.(cond (meter:count-only `(fillarray ,meter:count-array-name '(0))))
 (#.(meter:make-name 'meter:init-arrays) #.(meter:make-name 'meter:array-size)))

(eval-when (compile)
	   (funcall #'fixsw old-fixsw))
;;; For the metering system
;;; metaux.lap
;;; LAP stuff

(lap #.(meter:make-name 'meter:init-arrays) subr)
(args #.(meter:make-name 'meter:init-arrays) (nil . 1))
	(move t 0 a)
	(lsh t 1)
	(addi t (- arr 1))
	(setzm 0 arr)
	(hrli tt arr)
	(hrri tt arr)
	(addi tt 1)
	(blt tt 0 t)
	(movei a 't)
	(popj p)

;;; (meter:start-time)
(entry #.(meter:make-name 'meter:start-time) subr)
(args #.(meter:make-name 'meter:start-time) (nil . 0))
	(movei tt 0)
	(calli tt #o27)
	(exch fxp pdl)
	(push fxp tt)
	(exch fxp pdl)
	(movei a 't)
	(popj p)

;;; (meter:end-time <n> <increment>)
(entry #.(meter:make-name 'meter:end-time) subr)
(args #.(meter:make-name 'meter:end-time) (nil . 2))
	(movei tt 0)
	(calli tt #o27)
	(exch fxp pdl)
	(pop fxp t)
	(exch fxp pdl)
	(sub tt t)
	(move t 0 a)	;get index
	(addi t arr)
	(addm tt 0 t)
	(add t size)	;into next array
	(move b 0 b)	
	(addm b 0 t)	;increment
	(popj p)	;return the function-number

;;; (meter:inc-only <n> <increment>)
(entry #.(meter:make-name 'meter:inc-only) subr)
(args #.(meter:make-name 'meter:inc-only) (nil . 2))
	(move t 0 a)	;get index
	(addi t ari)
	(move b 0 b)
	(addm b 0 t)
	(popj p)	;return the function-number

;;; (meter:refr <n>)
(entry #.(meter:make-name 'meter:refr) subr)
(args #.(meter:make-name 'meter:refr) (nil . 1))
	(move t 0 a)	;get index
	(addi t arr)
	(move tt 0 t)
	(jrst 0 fix1)

;;; (meter:refi <n>)
(entry #.(meter:make-name 'meter:refi) subr)
(args #.(meter:make-name 'meter:refi) (nil . 1))
	(move t 0 a)	;get index
	(addi t ari)
	(move tt 0 t)
	(jrst 0 fix1)

size (#.(symeval meter:array-size))
arr (block #.(symeval meter:array-size))
ari (block #.(symeval meter:array-size))
stack (block 2000)
pdl (776000←22 0 stack)
inipdl (776000←22 0 stack)
()